home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / expect.scm.z / expect.scm
Text File  |  2002-07-08  |  5KB  |  156 lines
  1. ;;;;     Copyright (C) 1996, 1998, 1999 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;; 
  18.  
  19.  
  20. (define-module (ice-9 expect) :use-module (ice-9 regex))
  21.  
  22. ;;; Expect: a macro for selecting actions based on what it reads from a port.
  23. ;;; The idea is from Don Libes' expect based on Tcl.
  24. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  25.  
  26.  
  27. (define-public expect-port #f)
  28. (define-public expect-timeout #f)
  29. (define-public expect-timeout-proc #f)
  30. (define-public expect-eof-proc #f)
  31. (define-public expect-char-proc #f)
  32.  
  33. ;;; expect: each test is a procedure which is applied to the accumulating
  34. ;;; string.
  35. (defmacro-public expect clauses
  36.   (let ((s (gentemp))
  37.     (c (gentemp))
  38.     (port (gentemp))
  39.     (timeout (gentemp)))
  40.     `(let ((,s "")
  41.        (,port (or expect-port (current-input-port)))
  42.        ;; when timeout occurs, in floating point seconds.
  43.        (,timeout (if expect-timeout
  44.              (let* ((secs-usecs (gettimeofday)))
  45.                (+ (car secs-usecs)
  46.                   expect-timeout
  47.                   (/ (cdr secs-usecs)
  48.                  1000000))) ; one million.
  49.              #f)))
  50.        (let next-char ()
  51.      (if (and expect-timeout
  52.           (not (expect-select ,port ,timeout)))
  53.          (if expect-timeout-proc
  54.          (expect-timeout-proc ,s)
  55.          #f)
  56.          (let ((,c (read-char ,port)))
  57.            (if expect-char-proc
  58.            (expect-char-proc ,c))
  59.            (if (not (eof-object? ,c))
  60.            (set! ,s (string-append ,s (string ,c))))
  61.            (cond
  62.         ;; this expands to clauses where the car invokes the
  63.         ;; match proc and the cdr is the return value from expect
  64.         ;; if the proc matched.
  65.         ,@(let next-expr ((tests (map car clauses))
  66.                   (exprs (map cdr clauses))
  67.                   (body '()))
  68.             (cond
  69.              ((null? tests)
  70.               (reverse body))
  71.              (else
  72.               (next-expr
  73.                (cdr tests)
  74.                (cdr exprs)
  75.                (cons
  76.             `((,(car tests) ,s (eof-object? ,c))
  77.               ,@(cond ((null? (car exprs))
  78.                    '())
  79.                   ((eq? (caar exprs) '=>)
  80.                    (if (not (= (length (car exprs))
  81.                            2))
  82.                        (scm-error 'misc-error
  83.                           "expect"
  84.                           "bad recipient: ~S"
  85.                           (list (car exprs))
  86.                           #f)
  87.                        `((apply ,(cadar exprs)
  88.                         (,(car tests) ,s ,port)))))
  89.                   (else 
  90.                    (car exprs))))
  91.             body)))))
  92.         ;; if none of the clauses matched the current string.
  93.         (else (cond ((eof-object? ,c)
  94.                  (if expect-eof-proc
  95.                  (expect-eof-proc ,s)
  96.                  #f))
  97.                 (else
  98.                  (next-char)))))))))))
  99.  
  100.  
  101. (define-public expect-strings-compile-flags regexp/newline)
  102. (define-public expect-strings-exec-flags regexp/noteol)
  103.  
  104. ;;; the regexec front-end to expect:
  105. ;;; each test must evaluate to a regular expression.
  106. (defmacro-public expect-strings clauses
  107.   `(let ,@(let next-test ((tests (map car clauses))
  108.               (exprs (map cdr clauses))
  109.               (defs '())
  110.               (body '()))
  111.         (cond ((null? tests)
  112.            (list (reverse defs) `(expect ,@(reverse body))))
  113.           (else
  114.            (let ((rxname (gentemp)))
  115.              (next-test (cdr tests)
  116.                 (cdr exprs)
  117.                 (cons `(,rxname (make-regexp
  118.                          ,(car tests)
  119.                          expect-strings-compile-flags))
  120.                       defs)
  121.                 (cons `((lambda (s eof?)
  122.                       (expect-regexec ,rxname s eof?))
  123.                     ,@(car exprs))
  124.                       body))))))))
  125.  
  126. ;;; simplified select: returns #t if input is waiting or #f if timed out or
  127. ;;; select was interrupted by a signal.
  128. ;;; timeout is an absolute time in floating point seconds.
  129. (define-public (expect-select port timeout)
  130.   (let* ((secs-usecs (gettimeofday))
  131.      (relative (- timeout 
  132.               (car secs-usecs)
  133.               (/ (cdr secs-usecs)
  134.              1000000))))    ; one million.
  135.     (and (> relative 0)
  136.      (pair? (car (select (list port) '() '()
  137.                  relative))))))
  138.  
  139. ;;; match a string against a regexp, returning a list of strings (required
  140. ;;; by the => syntax) or #f.  called once each time a character is added
  141. ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
  142. (define-public (expect-regexec rx s eof?)
  143.   ;; if expect-strings-exec-flags contains regexp/noteol,
  144.   ;; remove it for the eof test.
  145.   (let* ((flags (if (and eof?
  146.              (logand expect-strings-exec-flags regexp/noteol))
  147.             (logxor expect-strings-exec-flags regexp/noteol)
  148.             expect-strings-exec-flags))
  149.      (match (regexp-exec rx s 0 flags)))
  150.     (if match
  151.     (do ((i (- (match:count match) 1) (- i 1))
  152.          (result '() (cons (match:substring match i) result)))
  153.         ((< i 0) result))
  154.     #f)))
  155.  
  156.